############################################################################
##
## Este modulo contem configuracoes e rotinas usadas para detectar
## excepcoes (exception handling), usando uma sintaxe identica 'a do
## Object Pascal (try{...} except {...} finally {...};).
##
## Introduz tambem uma classe EXCEPTION_OBJECT que e' usada para passar
## um hash com informacao sobre:
##  - A classe da excepcao (string definida pelo utilizador);
##  - A funcao onde a excepcao foi gerada;
##  - O modulo;
##  - O numero da linha;
##  - A mensagem de erro (definida pelo utilizador);
##  - Uma referencia para um objecto definido pelo utilizador. 
##
## A captura de excepcoes e' feita criando um handler temporario para os
## SIG DIE, nomeadamente o __DIE__ gerado pelo perl, por ser consistente
## e nao dependente da plataforma onde o script e' executado.
##
## Como o modulo so' captura o SIG DIE, para capturar outros signals o
## script deverá usar os seus proprios handlers e fazer com que gerem
## um SIG DIE. Por exemplo, o seguinte pragma
##
##    use sigtrap qw ( die untrapped normal-signals );
##
## fará o script onde esteja declarado converter qualquer normal-signal
## (HUP, INT, PIPE, TERM) num SIG DIE, fazendo com que sejam capturados.
##
## A razao pela qual nao se inclui outros SIG no proprio modulo visa
## permitir aos scripts manter o controlo sobre todos eles conforme for
## necessario.
##
## A sintaxe para capturar as excepcoes e':
##
##     try { ... } [ except { ... } ] [ finally { ... } ] ;
##
## * * * * * A T E N C A O * * * * *
## O ponto e virgula no final e' obrigatorio e de extrema importancia.
## Se nao for incluido o script sera' interrompido (ou gerada uma
## excepcao) com erro de sintaxe.
##
## O bloco try{} e' obrigatorio. Os blocos except{} e finally{} sao
## facultativos. Se presente, o bloco except{} so' e' executado se uma
## excepcao for gerada dentro do bloco try{}. O bloco finally{}, se
## presente, e' sempre executado, tenha ou nao sido gerada uma excepcao,
## e se tambem existir o bloco except{} sera' executado sempre antes do
## bloco finally{}.
##
## As excepcoes geradas no bloco try{} e passadas para o bloco except{}
## sao anuladas. Ou seja, a menos que nova excepcao seja gerada dentro
## do bloco except{}, em finda a sua execucao o script continuara' a
## ser executado, embora as consequencias de deixar seguir o script com
## uma excepcao nao processada sejam imprevisiveis.
##
## O mesmo nao acontece com o bloco finally{}. Se tiver sido gerada uma
## excepcao no bloco anterior ( try{} ou except{} ), o bloco finally{}
## sera' executado integralmente ( a menos que ele proprio gere uma
## nova excepcao ) e finda a sua execucao a excepcao pendente passa
## para fora do bloco, podendo entao ser capturada por eventual bloco
## try{} exterior ou o script sera' interrompido.
##
## Exemplos:
##
## try { ... } except { ... } ;
##
## try { ... } finally { ... } ;
##
## try { ... } except { ... } finally { ... } ;
##
## try { try { ... } except { ... } ; } except { ... } finally { ... } ;
##
## As excepcoes geradas dentro do bloco try{} sao passadas para os blocos
## except{} ou finally{} como objectos EXCEPTION_OBJECT. Se no bloco
## except{} for gerada alguma excepcao sera' passada tambem para o bloco
## finally{} como um objecto EXCEPTION_OBJECT.
##
## Por conveniencia, este modulo inclui uma funcao throw() que aceita como
## parametro uma string ou um objecto EXCEPTION_OBJECT. Pode ser usada em
## qualquer parte do codigo, mesmo fora dos blocos try/except/finally.
##
## Para, dentro dos blocos except{} ou finally{}, ter acesso ao objecto
## EXCEPTION_OBJECT criado para a excepcao gerada, basta usar os metodos
## normais de recolha de parametros de uma funcao, seja o shift ou o
## array @_.
##
## Exemplo:
##
## try
## {
##   ... 
## }
## except # so' e' executado se for gerada uma excepcao no bloco try{}
## {
##   my $e = shift; # recolhe o EXCEPTION_OBJECT com informacao da excepcao
##
##   print "Raised exception: $e"; # mostra informacao da excepcao
##   throw $e; # recria a excepcao
## };
##
## Note-se o comando 'throw $e' que recria a excepcao capturada. Sem isto,
## a' saida do bloco except{} o script continuaria a ser executado com uma
## excepcao nao processada.
## 
############################################################################
package exceptions;

use base 'Exporter'; # Exporter class
use Class::Struct;

our @EXPORT = qw(try except finally throw exception);

############################################################################
# EXCEPTION
#
# Cria e retorna uma referencia para um objecto EXCEPTION_OBJECT.
#
# Parametros:
#    $_[0] = valor a utilizar como classe da excepcao.
#    $_[1] = mensagem de erro.
#    $_[2] (opcional) = valor para o campo 'Object' da estrutura
#                       EXCEPTION_OBJECT.
#
sub exception ($$;$)
{
  my ($class, $msg, $obj) = @_;
  my ($func, $module, $line) = caller;

  return new EXCEPTION_OBJECT ($class, $msg, $obj, $func, $module, $line);
}
############################################################################

############################################################################
# THROW
#
# Alias para a funcao 'die', mais legivel no contexto try{}except{}finally{}
#
# Parametros:
#    $_[0] = referencia para um objecto EXCEPTION_OBJECT ou uma string com
#            a mensagem de erro, caso em que e' criado um objecto
#            EXCEPTION_OBJECT com a classe UNKNOWN.
#
sub throw ($)
{
  die __TestException(shift, caller);
}
############################################################################

############################################################################
# __ TEST EXCEPTION
#
# Testa se uma excepcao criada durante a execucao das clausulas e' um
# objecto EXCEPTION_OBJECT ou uma string. Se for uma string, cria um
# objecto com a classe UNKNOWN a partir da mensagem.
#
# Parametros:
#    $_[0] = objecto ou string com que se criou a excepcao.
#    $_[1] = array com o output da funcao 'caller'.
#
sub __TestException ($@)
{
  my $obj = shift;

  eval { $obj = new EXCEPTION_OBJECT ('UNKNOWN', $obj, 0, @_) }
    unless (ref $obj eq 'EXCEPTION_OBJECT');
  
  return $obj;
}
############################################################################

############################################################################
# __ RUN CLAUSE
#
# Executa o codigo associado a uma clausula.
#
# Retorna undef se nao for gerada nenhuma excepcao ou uma referencia para
# uma estrutura TRACK_EXCEPTION.
#
# Parametros:
#    $_[0] = referencia para a clausula a excutar.
#    $_[1] = parametro opcional para passar 'a clausula a executar.
#
sub __RunClause ($;$)
{
  my $clause = shift;
  my $param = shift;
  my $err;

  eval
  {
    # define um handler temporario para as excepcoes que possam ser
    # criadas durante a execucao da clausula
    local $SIG{'__DIE__'} = sub { $err = __TestException(shift, caller); };

    # executa o codigo associado 'a clausula
    $clause->($param);
  };
  
  return $err;
}
############################################################################

############################################################################
# __ EXECUTE CLAUSES
#
# Executa as clausulas try, except e/ou finally.
#
# Retorna undef ou a ultima excepcao gerada e nao processada.
#
# Parametros:
#    $_[0] = referencia para um hash com as clausulas a executar.
#
sub __ExecuteClauses ($)
{
  my $clauses = shift;

  # executa a clausula "try"
  my $err = __RunClause($clauses->{'try'});

  # se foi criada uma excepcao e existe uma clausula "except"
  if (($err) && (exists $clauses->{'except'}))
  {
    # usa uma copia da excepcao gerada
    my $e = $err;

    # executa o bloco except e captura qualquer excepcao gerada
    $err = __RunClause($clauses->{'except'}, $e);
  }

  # executa a clausula "finally", se existir
  if (exists ($clauses->{'finally'}))
  {
    # executa a clausula e captura qualquer excepcao gerada
    my $e = __RunClause($clauses->{'finally'}, $err);

    # se foi gerada alguma excepcao na clausula "finally" reporta-a,
    # caso contrario mantem a informacao sobre as excepcoes que hajam
    # sido criadas nas clausulas anteriores
    $err = $e if $e;
  }

  # retorna undef ou uma referencia para a ultima excepcao gerada.
  return $err;
}
############################################################################

############################################################################
# TRY
#
# Funcao para executar codigo protegido.
#
# Parametros:
#    $_[0] = referencia para o bloco de codigo protegido.
#    $_[1] = referencia para um hash retornado pela clausula imediatamente
#            seguinte, se existir.
#
sub try (&;$)
{
  my $try = shift;
  my $clauses = shift || {};

  # verifica a sintaxe do bloco try/except/finally
  die new EXCEPTION_OBJECT ('SINTAX', "Missing semicolon after 'try' block", 0, caller)
    unless (ref $clauses eq 'HASH') && (ref $try eq 'CODE');

  # adiciona a referencia para o codigo protegido ao hash %{$clauses}
  ${$clauses}{'try'} = $try;
  
  # executa o conjunto das clausulas try/except/finally
  my $err = __ExecuteClauses($clauses);

  # se existir uma excepcao nao tratada, gera-a novamente para ser captada
  # por blocos try/except/finally exteriores ou abortar a execucao do script
  die $err if $err;
}
############################################################################

############################################################################
# EXCEPT
#
# Funcao para registar o bloco de codigo associado a uma clausula "except".
#
# Retorna uma referencia para um hash com as clausulas ja' existentes e
# acrescido da referencia para a clausula "except".
#
# Parametros:
#    $_[0] = referencia para o bloco de codigo da clausula "except".
#    $_[1] = referencia para um hash retornado pela clausula imediatamente
#            seguinte, se existir.
#
sub except (&;$)
{
  my $except = shift;
  my $clauses = shift || {};

  # verifica a sintaxe do bloco try/except/finally
  die new EXCEPTION_OBJECT ('SINTAX', "Missing semicolon after 'except' block", 0, caller)
    unless (ref $clauses eq 'HASH') && (ref $except eq 'CODE');

  # adiciona a referencia para o bloco de codigo ao hash %{$clauses}
  ${$clauses}{'except'} = $except;
  
  # retorna o hash
  return $clauses;
}
############################################################################

############################################################################
# FINALLY
#
# Funcao para registar o bloco de codigo associado a uma clausula "finally".
#
# Retorna uma referencia para um hash com a clausula "finally".
#
# Parametros:
#    $_[0] = referencia para o bloco de codigo da clausula "finally".
#
sub finally (&;$)
{
  my $finally = shift;
  my $clauses = shift || {};

  # verifica a sintaxe do bloco try/except/finally
  die new EXCEPTION_OBJECT ('SINTAX', "Missing semicolon after 'finally' block", 0, caller)
    unless (ref $clauses eq 'HASH') && (ref $finally eq 'CODE');

  # adiciona a referencia para o bloco de codigo ao hash %{$clauses}
  ${$clauses}{'finally'} = $finally;

  # retorna o hash
  return $clauses;
}
############################################################################

1;

############################################################################
##
## Este modulo define a classe EXCEPTION_OBJECT
##
############################################################################
package EXCEPTION_OBJECT;

use overload '""' => stringify;

############################################################################
# NEW
#
# Class Constructor; Cria um novo objecto EXCEPTION_OBJECT.
#
# Retorna uma referencia para o objecto criado.
#
# Parametros:
#    $_[0] = Nome da classe (i.e. EXCEPTION_OBJECT).
#    $_[1] = Classe da excepcao, indicada na funcao "exception".
#    $_[2] = Mensagem descritiva da excepcao.
#    $_[3] = Valor indicado no terceiro parametro da funcao "exception".
#    $_[4] = Nome da funcao onde a excepcao foi gerada.
#    $_[5] = Nome do modulo/script onde a excepcao foi gerada.
#    $_[6] = Numero da linha onde a funcao foi gerada.
#
sub new
{
  my ($objectclass, $errorclass, $message, $object, $function, $module, $line) = @_;
  chomp $message;

  # cria um hash para o novo objecto
  my $self = {
        'Class'    => $errorclass, # nome ou numero que identifique o tipo de erro
        'Function' => $function,   # nome da funcao onde a excepcao foi gerada
        'Module'   => $module,     # nome do modulo onde a excepcao foi gerada
        'Line'     => $line,       # numero da linha onde a excepcao foi gerada
        'Message'  => $message,    # mensagem de erro definida pelo utilizador
        'Object'   => $object,     # definido pelo utilizador
        'Text'     => "$errorclass exception at $function in $module".
                      ", line $line, with message: $message\n",
        };
        
  # declara o hash como sendo um objecto EXCEPTION_OBJECT
  bless $self, $objectclass;
  
  # retorna a referencia para o novo objecto
  return $self;
}
############################################################################

############################################################################
# STRINGIFY
#
# Retorna uma string descritiva da excepcao sempre que uma referencia para
# um objecto EXCEPTION_OBJECT e' usada em string context.
#
# Parametros:
#    $_[0] = Referencia para o objecto EXCEPTION_OBJECT.
#
sub stringify
{
  my $self = shift;
  return $self->{Text};
}
############################################################################

1;
